home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / avltree.zip / AVLTREE.PAS < prev   
Pascal/Delphi Source File  |  1991-03-12  |  27KB  |  942 lines
  1. Program AvlTree;
  2.  
  3. TYPE  letters = set of '?'..'Z';
  4.  
  5. (* set the avaliable commands = a sub-string of type letters *)
  6. (* this allows for easy expansion or reduction of the program commands *)
  7.  
  8. CONST    availcommands : letters = ['A','D','P','X','?'];
  9.  
  10.  
  11.  
  12. type
  13.    string80 = string[80];
  14.    binarytree =  ^binarytreenode ;
  15.    binarytreenode = RECORD
  16.       data         : string80 ;      (* word stored in this node             *)
  17.       left         : binarytree ;    (* pointer to left subtree              *)
  18.       right        : binarytree ;    (* pointer to right subtree             *)
  19.       balance      : INTEGER ;       (* balance factor:  -1 = tall left,     *)
  20.                                      (*    0 = balanced, +1 = tall right     *)
  21.    END ;
  22.  
  23.  
  24. VAR root : binarytree ;   (* pointer to root of binary tree *)
  25.     dummyboolean : boolean;
  26.     data : string80;
  27.  
  28. (* Overall program header. *)
  29.  
  30. PROCEDURE Header ;
  31. BEGIN
  32.    WriteLn;
  33.    WriteLn;
  34.    Write ('AVL TREE BUILDING DEMONSTRATION') ;
  35.    WriteLn;
  36.    WriteLn;
  37.    WriteLn;
  38. END  ;
  39.  
  40.  
  41.  
  42.  
  43.  
  44. Function emptytree (tree : binarytree) : boolean;
  45.  
  46. (* returns true if tree is empty *)
  47. (* returns false if tree is not empty *)
  48.  
  49.   Begin
  50.  
  51.     IF tree = NIL THEN     (* check for empty tree *)
  52.  
  53.          begin
  54.            WriteLn;
  55.            WriteLn (' EMPTY TREE!!!!!!!');
  56.            WriteLn;
  57.            emptytree := true
  58.          end
  59.  
  60.     ELSE
  61.  
  62.       emptytree := false
  63.  
  64.  
  65.   End;  (* emptytree *)
  66.  
  67.  
  68.  
  69.  
  70. PROCEDURE inputtree (VAR data : String80);
  71.  
  72.  
  73.  
  74. (* this procedure inputs the name the user wants to add to the*)
  75. (* AVL tree *)
  76.  
  77.  
  78.   Begin
  79.  
  80.     WriteLn;
  81.     WriteLn ('Please enter the info for the node to be added');
  82.     WriteLn;
  83.  
  84.     Write ('        Name:  ');
  85.     ReadLn (data);
  86.  
  87.     WriteLn;
  88.  
  89.   End ; (*  inputtree *)
  90.  
  91.  
  92.  
  93.  
  94. Procedure showmenu;
  95.  
  96.      (* print the menu *)
  97.    Begin
  98.       WriteLn;
  99.       WriteLn ('Please type     A to add a node to the tree');
  100.       WriteLn ('                D to delete a node from the tree ');
  101.       WriteLn ('                P to print the current tree');
  102.       WriteLn ('                X to exit this program     ');
  103.       WriteLn;
  104.    End; (* showmenu *)
  105.  
  106. Procedure getkey (var key : String80);
  107.  
  108. (* this procedure gets the key to search for when *)
  109. (* deleting a node from the tree *)
  110.  
  111. Begin
  112.   WriteLn;
  113.   WriteLn ('Please enter the name you wish to delete. ');
  114.  
  115.   (* repeat this until the user enters something other than <return> *)
  116.   Repeat
  117.      Write ('-----> ');
  118.      ReadLn (key);
  119.  
  120.   Until key <> ''
  121.  
  122. End; (* getkey *)
  123.  
  124. PROCEDURE getcommand (VAR command : CHAR);
  125.  
  126. (* This procedure displays the avaliable commands and prompts the user *)
  127. (* for the command, which is returned the the caller *)
  128.  
  129.  
  130. VAR OK : BOOLEAN; (* a flag to tell if a valid command letter was entered *)
  131.  
  132.   Begin
  133.  
  134.     OK := FALSE;
  135.     WHILE NOT OK DO
  136.  
  137.      Begin
  138.  
  139.        Write ('Enter command. (? for help) ==> ');
  140.  
  141.        Readln (command);   (* gets input from the user *)
  142.  
  143.  
  144.        command := upcase (command); (* built in Turbo Pascal command *)
  145.                                 (* that converts a character to uppercase *)
  146. (* this is where the procedure checks for a valid entry *)
  147.  
  148.          OK := command in availcommands;
  149.  
  150.  
  151.      End (* WHILE *)
  152.  
  153. End ; (* getcommand *)
  154.  
  155.  
  156. PROCEDURE makenode
  157.    (VAR newnode : binarytree ;   (* pointer to appropriate parent of tree *)
  158.         wordtoadd   : string80) ;     (* word to add                  *)
  159.  
  160. BEGIN
  161.  
  162.    WriteLn ('');
  163.    Write ('-----> Making new node for "') ;
  164.    Write (wordtoadd) ;
  165.    Write ('"') ;
  166.    WriteLn;
  167.  
  168.    NEW (newnode) ;
  169.    WITH newnode^ DO
  170.     Begin
  171.       data := wordtoadd;
  172.       left := NIL ;
  173.       right := NIL ;
  174.       balance := 0 ;
  175.     END ;   (* WITH *)
  176.  
  177. END  ;
  178.  
  179.  
  180. (* This procedure rotates the tree to the left. *)
  181.  
  182. PROCEDURE rotateleft
  183.    (VAR root : binarytree ) ;   (* root of subtree to be rotated *)
  184.  
  185. VAR temp : binarytree ;         (* temporary pointer for rotating *)
  186.  
  187. BEGIN
  188.  
  189.    Write ('... performing a rotate left on "') ;
  190.    Write (root^.data) ;
  191.    Write ('"') ;
  192.    WriteLn;
  193.  
  194.    temp := root^.right ;
  195.    root^.right := temp^.left ;
  196.    temp^.left := root ;
  197.    root := temp ;
  198.  
  199. END  ;
  200.  
  201.  
  202.  
  203. (* This procedure rotates the tree to the right. *)
  204.  
  205. PROCEDURE rotateright
  206.    (VAR root : binarytree ) ;   (* root of subtree to be rotated *)
  207.  
  208. VAR temp : binarytree ;         (* temporary pointer for rotating *)
  209.  
  210. BEGIN
  211.  
  212.    Write ('... performing a rotate right on "') ;
  213.    Write (root^.data) ;
  214.    Write ('"') ;
  215.    WriteLn;
  216.  
  217.    temp := root^.left ;
  218.    root^.left := temp^.right ;
  219.    temp^.right := root ;
  220.    root := temp ;
  221.  
  222. END  ;
  223.  
  224.  
  225.  
  226. (* This procedure balances a tree whose right subtree is too tall. *)
  227.  
  228. PROCEDURE rightbalance
  229.    (VAR root   : binarytree ;   (* pointer to root of tree              *)
  230.     VAR taller : BOOLEAN ) ;    (* TRUE if height of tree has increased *)
  231.  
  232. VAR rightchild     : binarytree ;   (* pointer to right subtree of root      *)
  233.     grandleftchild : binarytree ;   (* pointer to left subtree of rightchild *)
  234.  
  235. BEGIN
  236.  
  237.    WriteLn;
  238.    Write ('... performing a right balance on "') ;
  239.    Write (root^.data) ;
  240.    Write ('"') ;
  241.    WriteLn;
  242.  
  243.    rightchild := root^.right ;
  244.    CASE rightchild^.balance OF
  245.  
  246.                (* double rotation required *)
  247.  
  248.         -1 : begin
  249.              grandleftchild := rightchild^.left ;
  250.              CASE grandleftchild^.balance OF
  251.                   -1 : begin
  252.                          root^.balance :=  0 ;
  253.                          rightchild^.balance := +1
  254.                        end;
  255.                    0 : begin
  256.                          root^.balance :=  0 ;
  257.                          rightchild^.balance :=  0
  258.                        end;
  259.                    1 : begin
  260.                          root^.balance := -1 ;
  261.                          rightchild^.balance :=  0
  262.                        end
  263.              END ;   (* CASE grandleftchild^.balance OF *)
  264.              grandleftchild^.balance := 0 ;
  265.  
  266.              rotateright (rightchild) ;
  267.              root^.right := rightchild ;
  268.              rotateleft (root) ;
  269.              taller := FALSE ;
  270.  
  271.                 (* impossible case *)
  272.             end;
  273.          0 : begin
  274.                WriteLn ('');
  275.                Write ('ERROR:  root^.balance = 0 in balanceright') ;
  276.                WriteLn ('');
  277.                WriteLn ('')
  278.              end;
  279.  
  280.                 (* single rotation required *)
  281.  
  282.          1 : begin
  283.                root^.balance := 0 ;
  284.                rightchild^.balance := 0 ;
  285.                rotateleft (root) ;
  286.                taller := FALSE
  287.              end
  288.  
  289.    END ;   (* CASE root^.balance OF *)
  290.  
  291. END  ;
  292.  
  293.  
  294.  
  295. (* This procedure balances a tree whose left subtree is too tall. *)
  296.  
  297. PROCEDURE leftbalance
  298.    (VAR root   : binarytree ;   (* pointer to root of tree              *)
  299.     VAR taller : BOOLEAN ) ;    (* TRUE if height of tree has increased *)
  300.  
  301. VAR leftchild       : binarytree ;  (* pointer to left subtree of root       *)
  302.     grandrightchild : binarytree ;  (* pointer to right subtree of leftchild *)
  303.  
  304. BEGIN
  305.  
  306.    WriteLn;
  307.    Write ('... performing a left balance on "') ;
  308.    Write (root^.data) ;
  309.    Write ('"') ;
  310.    WriteLn;
  311.  
  312.    leftchild := root^.left ;
  313.  
  314.    CASE leftchild^.balance OF
  315.  
  316.                 (* single rotation required *)
  317.  
  318.         -1 : begin
  319.                root^.balance := 0 ;
  320.                leftchild^.balance := 0 ;
  321.                rotateright (root) ;
  322.                taller := FALSE
  323.              end;
  324.  
  325.                 (* impossible case *)
  326.  
  327.          0 : begin
  328.                WriteLn;
  329.                Write ('ERROR:  root^.balance = 0 in balanceleft') ;
  330.                WriteLn;
  331.                WriteLn;
  332.              end;
  333.  
  334.                 (* double rotation required *)
  335.  
  336.          1 : begin
  337.                grandrightchild := leftchild^.right ;
  338.                CASE grandrightchild^.balance OF
  339.                   -1 : begin
  340.                          root^.balance := +1 ;
  341.                          leftchild^.balance :=  0
  342.                        end;
  343.                    0 : begin
  344.                          root^.balance :=  0 ;
  345.                          leftchild^.balance :=  0
  346.                        end;
  347.                    1 : begin
  348.                          root^.balance :=  0 ;
  349.                          leftchild^.balance := -1
  350.                        end;
  351.               END ;   (* CASE grandrightchild^.balance OF *)
  352.                grandrightchild^.balance := 0 ;
  353.  
  354.                rotateleft (leftchild) ;
  355.                root^.left := leftchild ;
  356.                rotateright (root) ;
  357.                taller := FALSE ;
  358.              end
  359.    END ;   (* CASE root^.balance OF *)
  360.  
  361. END  ;
  362.  
  363.  
  364.  
  365. (* This procedure adds a node to the binary tree *)
  366.  
  367. PROCEDURE AddBinTreeString
  368.    (VAR root   : binarytree ;   (* pointer to root of tree                 *)
  369.     dataword   : string80 ;     (* word to find and add if not in tree     *)
  370.     VAR taller : BOOLEAN ) ;    (* TRUE if height of tree has increased    *)
  371.  
  372. VAR tallersubtree : BOOLEAN ;   (* TRUE if height of subtree has increased *)
  373.  
  374.  
  375. BEGIN
  376.  
  377.       (* handle the case where the tree is empty *)
  378.  
  379.    IF root = NIL THEN
  380.      begin
  381.       makenode (root, dataword) ;
  382.       taller := TRUE ;
  383.      end
  384.  
  385.    ELSE
  386.          (* handle the case where word the already exists in the tree *)
  387.  
  388.       IF dataword = root^.data THEN
  389.         begin
  390.           WriteLn; WriteLn ('duplicate!'); WriteLn;
  391.           taller := FALSE ;
  392.         end
  393.  
  394.          (* handle an insert to the left *)
  395.  
  396.       ELSE
  397.        IF dataword < root^.data THEN
  398.         begin
  399.          AddBinTreeString (root^.left, dataword, tallersubtree) ;
  400.          IF tallersubtree THEN
  401.             CASE root^.balance OF
  402.                  -1 : leftbalance (root, taller) ;
  403.                   0 : begin
  404.                         root^.balance := -1 ;
  405.                         taller := TRUE ;
  406.                       end;
  407.                   1 : begin
  408.                         root^.balance :=  0 ;
  409.                         taller := FALSE ;
  410.                       end
  411.             END    (* CASE balance OF *)
  412.          ELSE
  413.             taller := FALSE ;
  414.         END    (*   *)
  415.          (* handle an insert to the right *)
  416.  
  417.       ELSE
  418.         begin
  419.          AddBinTreeString (root^.right, dataword, tallersubtree) ;
  420.          IF tallersubtree THEN
  421.             CASE root^.balance OF
  422.                  -1 : begin
  423.                         root^.balance := 0 ;
  424.                         taller := FALSE ;
  425.                       end;
  426.                   0 : begin
  427.                         root^.balance := 1 ;
  428.                         taller := TRUE ;
  429.                       end;
  430.                   1 : rightbalance (root, taller) ;
  431.             END    (* CASE balance OF *)
  432.          ELSE
  433.             taller := FALSE ;
  434.          END ;   (* IF tallersubtree THEN  *)
  435.  
  436. END  ;
  437.  
  438.  
  439.  
  440. (* This procedure shows the tree structure using a modified *)
  441. (* inorder traversal (RNL instead of LNR).                  *)
  442.  
  443. PROCEDURE showtree
  444.    (root      : binarytree ;   (* pointer to root of tree       *)
  445.     level     : integer ;     (* recursion level               *)
  446.     subtreeid : CHAR ) ;       (* L = left, R = right, O = root *)
  447.  
  448. VAR k : integer ;   (* local loop index *)
  449.  
  450. BEGIN
  451.  
  452.       (* return if empty subtree *)
  453.  
  454.    IF root = NIL THEN exit  ;
  455.  
  456.       (* recurse for right subtree *)
  457.  
  458.    showtree (root^.right, level+1, 'R') ;
  459.  
  460.       (* process current node *)
  461.  
  462.    FOR k := 1 TO level DO                (* indent to current level *)
  463.       Write ('   ') ;
  464.  
  465.    CASE subtreeid OF                     (* show subtree id *)
  466.         'L' : Write ('Left  ') ;
  467.         'O' : Write ('Root  ') ;
  468.         'R' : Write ('Right ') ;
  469.    END ;
  470.  
  471.    Write (' ') ;
  472.    Write (root^.data) ;
  473.    Write (' ') ;
  474.  
  475.    Write (' (') ;                  (* show balance field *)
  476.    CASE root^.balance OF
  477.         -1 : Write ('-') ;
  478.          0 : Write ('0') ;
  479.          1 : Write ('+') ;
  480.    END ;
  481.    Write (')') ; WriteLn ('');
  482.  
  483.       (* recurse for left subtree *)
  484.  
  485.    showtree (root^.left, level+1, 'L') ;
  486.  
  487. END  ;
  488.  
  489.  
  490.  
  491. (* This procedure finds a node that the user wants to delete.*)
  492.  
  493. PROCEDURE findnode
  494.  
  495.    (root             : binarytree ;    (* pointer to root of tree       *)
  496.     keytodelete      : string80 ;      (* node key to find for deletion *)
  497.     VAR parent       : binarytree ;    (* parent of node to delete      *)
  498.     VAR nodetodelete : binarytree ) ;  (* pointer to node to delete     *)
  499.  
  500. BEGIN
  501.    IF root = NIL THEN
  502.       begin
  503.         nodetodelete := NIL ;
  504.         exit ;
  505.       end
  506.    ELSE
  507.       if keytodelete < root^.data then
  508.             begin
  509.                   parent := root ;
  510.                   nodetodelete := root^.left ;
  511.                   findnode (root^.left, keytodelete, parent, nodetodelete) ;
  512.             end
  513.          else if keytodelete = root^.data then
  514.                 begin
  515.                   nodetodelete := root ;
  516.                   exit ;
  517.                 end
  518.                else if keytodelete > root^.data then
  519.                 begin
  520.                   parent := root ;
  521.                   nodetodelete := root^.right ;
  522.                   findnode (root^.right, keytodelete, parent, nodetodelete);
  523.                 end
  524.                 else WriteLn ('not here!')
  525.  
  526. END  ;
  527.  
  528.  
  529.  
  530. (* Wirth version of AVL tree delete left balance, Wirth page 225, called *)
  531. (* when left branch has shrunk.                                          *)
  532.  
  533. PROCEDURE balanceLeft
  534.    (VAR root    : binarytree ;   (* pointer to root of tree           *)
  535.     VAR shorter : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)
  536.  
  537. VAR rightchild     : binarytree ;  (* pointer to right subtree of root      *)
  538.     grandleftchild : binarytree ;  (* pointer to left subtree of rightchild *)
  539.  
  540. BEGIN
  541.    WriteLn;
  542.    Write ('... performing a delete left balance on "') ;
  543.    Write (root^.data) ;
  544.    Write ('"') ;
  545.    WriteLn;
  546.  
  547.    CASE root^.balance OF
  548.  
  549.         -1 : root^.balance := 0 ;
  550.  
  551.          0 : begin
  552.                root^.balance := +1 ;
  553.                shorter := FALSE ;
  554.              end;
  555.  
  556.         +1 : begin
  557.                rightchild := root^.right ;
  558.  
  559.                IF rightchild^.balance >= 0 THEN       (* single left rotation 
  560. *)
  561.                 begin
  562.                  Write ('... performing a single left rotation on "') ;
  563.                  Write (root^.data) ;
  564.                  Write ('"') ;
  565.                  WriteLn;
  566.  
  567.                  root^.right := rightchild^.left ;
  568.                  rightchild^.left := root ;
  569.                  IF rightchild^.balance = 0 THEN
  570.                     begin
  571.                       root^.balance := +1 ;
  572.                       rightchild^.balance := -1 ;
  573.                       shorter := FALSE ;
  574.                     end
  575.                  ELSE
  576.                     begin
  577.                       root^.balance := 0 ;
  578.                       rightchild^.balance := 0 ;
  579.                     end;
  580.                  root := rightchild;
  581.                end
  582.              ELSE   (* double left-right rotation *)
  583.                begin
  584.                 Write ('... performing a double left-right ') ;
  585.                 Write ('rotation on "') ;
  586.                 Write (root^.data) ;
  587.                 Write ('"') ;
  588.                 WriteLn;
  589.  
  590.                 grandleftchild := rightchild^.left ;
  591.                 rightchild^.left := grandleftchild^.right ;
  592.                 grandleftchild^.right := rightchild ;
  593.                 root^.right := grandleftchild^.left ;
  594.                 grandleftchild^.left := root ;
  595.                 IF grandleftchild^.balance = +1 THEN
  596.                    root^.balance := -1
  597.                 ELSE
  598.                    root^.balance :=  0 ;
  599.  
  600.                 IF grandleftchild^.balance = -1 THEN
  601.                    rightchild^.balance := +1
  602.                 ELSE
  603.                    rightchild^.balance :=  0 ;
  604.  
  605.                 root := grandleftchild ;
  606.                 grandleftchild^.balance := 0 ;
  607.                end (*begin..end*)
  608.              END ;   (* IF rightchild^.balance >= 0 ... *)
  609.  
  610.    END ;   (* CASE root^.balance OF *)
  611.  
  612. END  ;
  613.  
  614.  
  615.  
  616. (* Wirth version of AVL tree delete right balance, Wirth page 226, called *)
  617. (* when right branch has shrunk.                                          *)
  618.  
  619. PROCEDURE balanceRight
  620.    (VAR root    : binarytree ;   (* pointer to root of tree           *)
  621.     VAR shorter : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)
  622.  
  623. VAR leftchild       : binarytree ;  (* pointer to right subtree of root      *)
  624.     grandrightchild : binarytree ;  (* pointer to left subtree of rightchild *)
  625.  
  626. BEGIN
  627.  
  628.    WriteLn;
  629.    Write ('... performing a delete right balance on "') ;
  630.    Write (root^.data) ;
  631.    Write ('"') ;
  632.    WriteLn;
  633.  
  634.    CASE root^.balance OF
  635.  
  636.         +1 : root^.balance := 0 ;
  637.  
  638.          0 : begin
  639.                root^.balance := -1 ;
  640.                shorter := FALSE ;
  641.              end;
  642.         -1 : begin
  643.                leftchild := root^.left ;
  644.             IF leftchild^.balance <= 0 THEN       (* single right rotation *)
  645.                 begin
  646.                   Write ('... performing a single right rotation on "') ;
  647.                   Write (root^.data) ;
  648.                   Write ('"') ;
  649.                   WriteLn;
  650.  
  651.                   root^.left := leftchild^.right ;
  652.                   leftchild^.right := root ;
  653.                  IF leftchild^.balance = 0 THEN
  654.                    begin
  655.                      root^.balance := -1 ;
  656.                      leftchild^.balance := +1 ;
  657.                      shorter := FALSE ;
  658.                    end
  659.                  ELSE
  660.                    root^.balance := 0 ;
  661.                    leftchild^.balance := 0 ;
  662.                  END ;   (* IF leftchild^.balance 0 ... *)
  663.                  root := leftchild ;
  664.                 end (*begin end*)
  665.              ELSE   (* double right-left rotation *)
  666.               begin
  667.                 Write ('... performing a double right-left ') ;
  668.                 Write ('rotation on "') ;
  669.                 Write (root^.data) ;
  670.                 Write ('"') ;
  671.                 WriteLn;
  672.  
  673.                 grandrightchild := leftchild^.right ;
  674.                 leftchild^.right := grandrightchild^.left ;
  675.                 grandrightchild^.left := leftchild ;
  676.                 root^.left := grandrightchild^.right ;
  677.                 grandrightchild^.left := root ;
  678.  
  679.                 IF grandrightchild^.balance = -1 THEN
  680.                    root^.balance := +1
  681.                 ELSE
  682.                    root^.balance :=  0 ;
  683.  
  684.  
  685.                 IF grandrightchild^.balance = +1 THEN
  686.                    leftchild^.balance := -1
  687.                 ELSE
  688.                    leftchild^.balance :=  0 ;
  689.  
  690.  
  691.                 root := grandrightchild ;
  692.                 grandrightchild^.balance := 0 ;
  693.  
  694.              end (* begin end *)
  695.  
  696.    END ;   (* CASE root^.balance OF *)
  697.  
  698. END  ;
  699.  
  700.  
  701.  
  702. (* Wirth version of AVL tree delete, Wirth page 226. *)
  703.  
  704. PROCEDURE WirthDelete
  705.    (tkey        : string80 ;     (* name to search for                *)
  706.     VAR root    : binarytree ;   (* pointer to root of tree           *)
  707.     VAR shorter : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)
  708.  
  709.    (* The following variable is local to procedure WirthDelete and global *)
  710.    (* to all procedures embeded within WirthDelete.                       *)
  711.  
  712. VAR remove : binarytree ;   (* pointer to node to be removed *)
  713.  
  714.       (* The following embedded procedure "deletes" a node with two *)
  715.       (* children and resets the pointer to the node to be removed  *)
  716.  
  717.    PROCEDURE SubDel
  718.       (VAR nodetocopy : binarytree ;   (* pointer to node to be copied --   *)
  719.                                        (*    N.B. resetting nodetocopy      *)
  720.                                        (*    resets pointer from parent     *)
  721.        VAR shorter    : BOOLEAN ) ;    (* TRUE if resultant tree is shorter *)
  722.    BEGIN
  723.       IF nodetocopy^.right <> NIL THEN            (* recursive search for *)
  724.        begin                                        (*    rightmost node    *)
  725.          SubDel (nodetocopy^.right, shorter) ;
  726.          IF shorter THEN balanceRight (nodetocopy, shorter)  ;
  727.        end
  728.       ELSE
  729.         begin
  730.          remove^.data := nodetocopy^.data ;   (* copy data to node to       *)
  731.                                               (*   be "deleted"             *)
  732.          remove := nodetocopy ;               (* reset node to be "removed" *)
  733.          nodetocopy := nodetocopy^.left ;     (* reassign pointer from      *)
  734.                                               (*    parent                  *)
  735.          shorter := TRUE ;
  736.         END ;
  737.    END  ;
  738.  
  739.  
  740.    (* The mainline of the procedure "deletes" and "removes" a node *)
  741.    (* with zero or one NIL children.                               *)
  742.  
  743. BEGIN   (* WirthDelete *)
  744.  
  745.    IF root = NIL THEN     (* handle key not found condition *)
  746.       exit ;
  747.  
  748.       (* recursive search for key in non-NIL subtree *)
  749.  
  750.    IF root^.data > tkey THEN
  751.      begin
  752.       WirthDelete (tkey, root^.left, shorter) ;
  753.       IF shorter THEN balanceLeft (root, shorter)  ;
  754.      end
  755.    ELSe
  756.     IF root^.data > tkey THEN
  757.      begin
  758.       WirthDelete (tkey, root^.right, shorter) ;
  759.       IF shorter THEN balanceRight (root, shorter) ;
  760.      end
  761.  
  762.    ELSE
  763.     begin
  764.       remove := root ;           (* set node to be removed (DISPOSEd) *)
  765.  
  766.       IF remove^.right = NIL THEN
  767.          begin
  768.            root := remove^.left ;    (* NIL right child *)
  769.            shorter := TRUE ;
  770.          end
  771.       ELSe
  772.        IF remove^.left = NIL THEN
  773.          begin
  774.            root := remove^.right ;   (* NIL left child  *)
  775.            shorter := TRUE ;
  776.          end
  777.       ELSE
  778.         begin
  779.          SubDel (remove^.left, shorter) ;  (* two non-NIL children *)
  780.          IF shorter THEN balanceLeft (root, shorter)  ;
  781.         end;
  782.  
  783.       DISPOSE (remove) ;             (* do the actual "remove" *)
  784.     end
  785.  
  786. END ;
  787.  
  788.  
  789.  
  790. (* This procedure asks the user if s/he wants to delete any nodes and calls *)
  791. (* the deletion routines if necessary.                                      *)
  792.  
  793.  
  794. PROCEDURE DeleteNodes
  795.    (VAR root : binarytree ) ;     (* pointer to root of binary tree *)
  796.  
  797. VAR keytodelete  : string80 ;     (* node key to find for deletion     *)
  798.     parent       : binarytree ;   (* parent of node to delete          *)
  799.     nodetodelete : binarytree ;   (* pointer to node to delete         *)
  800.     shorter      : BOOLEAN ;      (* TRUE if resultant tree is shorter *)
  801.  
  802. BEGIN
  803.  
  804.    REPEAT
  805.  
  806.          (* get key to delete *)
  807.  
  808.       WriteLn;
  809.       getkey (keytodelete);
  810.       parent := NIL ;
  811.       nodetodelete := root ;
  812.       findnode (root, keytodelete, parent, nodetodelete) ;
  813.  
  814.          (* print tree if user entered 'p' *)
  815.  
  816.       IF upcase (keytodelete[1]) = 'P' THEN
  817.         begin
  818.          WriteLn;
  819.          IF root = NIL THEN
  820.             Write ('Tree is empty.')
  821.          ELSE
  822.            begin
  823.             showtree (root, 0, 'O') ;   (* for avltree version *)
  824.             WriteLn; WriteLn;
  825.            end
  826.         end
  827.          (* confirm to user whether node exists or not *)
  828.  
  829.       ELSe
  830.        IF NOT (upcase (keytodelete[1]) = 'X') THEN
  831.         begin
  832.          WriteLn;
  833.          Write ('-----> Deleting node for "') ;
  834.          Write (keytodelete) ;
  835.          Write ('"') ; WriteLn; WriteLn;
  836.  
  837.          IF nodetodelete = NIL THEN
  838.             begin
  839.               Write ('Node does not exist.') ; WriteLn;
  840.               WriteLn; WriteLn;
  841.             end
  842.          ELSe
  843.           IF parent = NIL THEN
  844.             begin
  845.               Write ('Root is to be deleted.') ; WriteLn;
  846.             end
  847.          ELSE
  848.            begin
  849.             Write ('Parent of node is "') ;
  850.             Write (parent^.data) ;
  851.             Write ('".') ; WriteLn;
  852.            END ;
  853.  
  854.             (* state number of children and go perform deletion *)
  855.  
  856.          IF nodetodelete <> NIL THEN
  857.           IF (nodetodelete^.left = NIL) AND (nodetodelete^.right = NIL) THEN
  858.                begin
  859.                  Write ('Node to delete has no children.') ; WriteLn ;
  860.                end
  861.             ELSe
  862.              IF nodetodelete^.right = NIL THEN
  863.                begin
  864.                  Write ('Node to delete has a single left child.') ;
  865.                  WriteLn;
  866.                end
  867.             ELSe
  868.              IF nodetodelete^.left = NIL THEN
  869.                begin
  870.                  Write ('Node to delete has a single right child.') ;
  871.                  WriteLn;
  872.                end
  873.             ELSE
  874.                begin
  875.                  Write ('Node to delete has two children.') ; WriteLn;
  876.                end;
  877.             shorter := FALSE ;
  878.             WirthDelete (keytodelete, root, shorter) ;
  879.             WriteLn;
  880.             IF root = NIL THEN
  881.                Write ('Tree is now empty.')
  882.             ELSE
  883.                showtree (root, 0, 'O') ;   (* for avltree version *)
  884.             WriteLn; WriteLn;
  885.         end (* begin..end *)
  886.  
  887.    UNTIL upcase (keytodelete[1]) = 'X' ;
  888.  
  889. END ;
  890.  
  891.  
  892. PROCEDURE menu (tree : binarytree);
  893.  
  894. (* this procedure controls what happens while the program is running *)
  895. (* it calls the procedures needed to run the program correctly *)
  896.  
  897.  
  898.   var command : CHAR; (* stores the function to perform on the tree *)
  899.       name : String80;     (*  used to hold the user inputted data *)
  900.  
  901.    Begin
  902.  
  903.      tree := NIL;  (* reset the tree *)
  904.      showmenu;
  905.  
  906.      REPEAT
  907.  
  908.        getcommand (command);   (* ask the user what to do *)
  909.  
  910.        CASE command OF
  911.           'A' : Begin
  912.                   inputtree (name);
  913.                   addbintreestring (tree,name,dummyboolean)
  914.                 End;
  915.           'D' : Begin
  916.  
  917.                   (* check to make sure tree is NOT empty *)
  918.                   if not (emptytree(tree)) then
  919.                      Begin
  920.                        deletenodes (tree)
  921.                      End
  922.  
  923.                 End;
  924.           'P' : showtree (tree,0,'O');
  925.           '?' : showmenu;
  926.           'X' : ;
  927.        End; (*CASE*)
  928.  
  929.      UNTIL command = 'X'   (* when "X" then quit *)
  930.  
  931.   End ;
  932.  
  933.  
  934.  
  935. BEGIN   (* avltree mainline *)
  936.     root := nil;
  937.     header;
  938.     menu (root);
  939.  
  940. END .
  941.  
  942.